home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / amok_lha / amok44.lha / Analyse3.01 / analyse.mod < prev    next >
Text File  |  1993-08-15  |  38KB  |  1,067 lines
  1. (* $f- $n- $r- $s- $v- *)
  2.  
  3. (************************************)
  4. (*                                  *)
  5. (*   analyse V 3.01  22-aug-1989    *)
  6. (*                                  *)
  7. (*       (C) by Lothar Schwab       *)
  8. (*     created by Lothar Schwab     *)
  9. (*                                  *)
  10. (************************************)
  11.  
  12. IMPLEMENTATION MODULE analyse;
  13. FROM SYSTEM         IMPORT FFP        , ADR           , ADDRESS;
  14. FROM Exec           IMPORT WaitPort   , GetMsg        , PutMsg     ,
  15.                            Message    , MsgPortPtr    , MemReqs    ,
  16.                            MemReqSet  , AllocMem      , FreeMem;
  17. FROM Dos            IMPORT LoadSeg    , UnLoadSeg     , CreateProc ,
  18.                            ProcessId;
  19. FROM Arts           IMPORT Assert     , TermProcedure;
  20. FROM ExecSupport    IMPORT CreatePort , DeletePort;
  21. FROM FFPConversions IMPORT RealToStr;
  22. FROM Conversions    IMPORT ValToStr;
  23. FROM MathTrans      IMPORT Sin   , Cos  , Tan  , Asin , Acos , Atan ,
  24.                            Sinh  , Cosh , Tanh , Exp  , Log  , Pow  ,
  25.                            Log10 , Sqrt;
  26. FROM Str            IMPORT CopyPos;
  27. CONST pizahl        = 3.1415926536;
  28.       pihalbe       = 1.5707963268;
  29.       ezahl         = 2.7182818284;
  30.       lnzehn        = 2.3025850930;
  31.       max           =  1.0E18;
  32.       mmax          = -1.0E18;
  33.       lnmax         = 41.4465;
  34.       fnamenlaenge  =   7;
  35.       endezeichen   = CHAR (0);
  36.       blank         = ' ';
  37. TYPE knotentypen    = (
  38.                        operationsknoten , funktionsknoten ,
  39.                        reellzahlknoten  , ganzzahlknoten  ,
  40.                        variablenknoten
  41.                       );
  42.      verknuepfungen = ( plus , minus , mal , durch , hoch );
  43.      funktionen     = (
  44.                        sinush   , cosinush   , tangensh   , cotangensh   ,
  45.                        arsinush , arcosinush , artangensh , arcotangensh ,
  46.                        sinus    , cosinus    , tangens    , cotangens    ,
  47.                        arcsinus , arccosinus , arctangens , arccotangens ,
  48.                        ehoch    , lne        , lg         , pot10        ,
  49.                        wurzel   , quadrat    , ende
  50.                       );
  51.      jobtypen       = (
  52.                        jobfunktion , jobcodegen ,
  53.                        jobcodeloe  , jobcodeanf ,
  54.                        jobkill
  55.                       );
  56.      knotenzeiger   = POINTER TO knoten;
  57.      knoten         = RECORD
  58.                         links , rechts : knotenzeiger;
  59.                         invers         : BOOLEAN;
  60.                         CASE typ : knotentypen OF
  61.                           operationsknoten : operation : verknuepfungen
  62.                         | funktionsknoten  : funktion  : funktionen
  63.                         | reellzahlknoten  : reellzahl : FFP
  64.                         | ganzzahlknoten   : ganzzahl  : INTEGER
  65.                         | variablenknoten  : variable  : CHAR
  66.                         END (* CASE *)
  67.                       END (* RECORD *);
  68.      lkopftyp       = ARRAY knotentypen OF knotenzeiger;
  69.      string         = ARRAY [1      .. fnamenlaenge] OF CHAR;
  70.      startupmsgtyp  = RECORD
  71.                         startupkopf : Message;
  72.                         kportadr    : ADDRESS;
  73.                         errorflg    : CHAR
  74.                       END;
  75.      kommandomsgtyp = RECORD
  76.                         kommandokopf : Message;
  77.                         knotenadr    : knotenzeiger;
  78.                         xwert        : FFP;
  79.                         ywert        : FFP;
  80.                         zwert        : FFP;
  81.                         codeadr      : ADDRESS;
  82.                         job          : jobtypen;
  83.                         fehlerflg    : CHAR;
  84.                         ergebniss    : FFP
  85.                       END;
  86. VAR  fnamen       : ARRAY [sinush .. ende ] OF string;
  87.      serverseg    : ADDRESS;
  88.      serverproc   : ProcessId;
  89.      replyportptr : MsgPortPtr;
  90.      startupmsg   : startupmsgtyp;
  91.      kommandomsg  : kommandomsgtyp;
  92.      dummy        : ADDRESS;
  93.      kommandoport : MsgPortPtr;
  94.  
  95. PROCEDURE macheknoten ( VAR baum : knotenzeiger ; art : knotentypen );
  96.   BEGIN
  97.     baum := AllocMem ( SIZE ( knoten ) , MemReqSet { memClear } );
  98.     baum^.typ    := art;
  99.     baum^.links  := NIL;
  100.     baum^.rechts := NIL
  101.   END macheknoten;
  102.  
  103. PROCEDURE shootdownserver;
  104.   BEGIN
  105.     kommandomsg.job := jobkill;
  106.     PutMsg     ( kommandoport , ADR ( kommandomsg ) );
  107.     WaitPort   ( replyportptr                       );
  108.     dummy           := GetMsg       ( replyportptr  );
  109.     UnLoadSeg  ( serverseg                          );
  110.     DeletePort ( replyportptr                       )
  111.   END shootdownserver;
  112.  
  113. PROCEDURE optimiere ( VAR baum : knotenzeiger ); FORWARD;
  114.  
  115. PROCEDURE infix ( VAR string : ARRAY OF CHAR ; baum : knotenzeiger );
  116.   TYPE wannklammern = SET OF verknuepfungen;
  117.   VAR  i , j , max  : CARDINAL;
  118.        feld         : ARRAY [1 .. 20] OF CHAR;
  119.        negklammer   : BOOLEAN;
  120.  
  121.   PROCEDURE infix2 ( baum : knotenzeiger ); FORWARD;
  122.  
  123.   PROCEDURE klammerbaum ( baum : knotenzeiger );
  124.     BEGIN
  125.       IF i < max THEN
  126.         string [i] := '(';
  127.         INC ( i );
  128.         infix2 ( baum );
  129.         IF i < max THEN
  130.           string [i] := ')';
  131.           INC ( i )
  132.         ELSE ok := FALSE
  133.         END (* IF *)
  134.       ELSE ok := FALSE
  135.       END (* IF *)
  136.     END klammerbaum;
  137.  
  138.   PROCEDURE opbaum ( baum : knotenzeiger ; klammerops : wannklammern );
  139.     VAR re , li : knotenzeiger;
  140.     BEGIN
  141.       re := baum^.rechts;
  142.       li := baum^.links;
  143.       IF ( li^.typ = operationsknoten  ) AND
  144.          ( li^.operation IN klammerops ) THEN
  145.         klammerbaum ( li )
  146.       ELSE
  147.         infix2      ( li )
  148.       END (* IF *);
  149.       IF ok AND ( i < max ) THEN
  150.         CASE baum^.operation OF
  151.           plus  : string [i] := '+'
  152.         | minus : string [i] := '-'
  153.         | mal   : string [i] := '*'
  154.         | durch : string [i] := '/'
  155.         | hoch  : string [i] := '^'
  156.         END (* CASE *);
  157.         INC ( i );
  158.         IF ( re^.typ = operationsknoten  ) AND
  159.            ( re^.operation IN klammerops ) THEN
  160.           klammerbaum ( re )
  161.         ELSE
  162.           infix2      ( re )
  163.         END (* IF *)
  164.       ELSE ok := FALSE
  165.       END (* IF *)
  166.     END opbaum;
  167.  
  168.   PROCEDURE infix2 ( baum : knotenzeiger );
  169.     BEGIN (* von infix2 *)
  170.       IF ( baum # NIL ) AND ok THEN
  171.         IF i < max THEN
  172.           CASE baum^.typ OF
  173.             operationsknoten :
  174.               CASE baum^.operation OF
  175.                 plus , minus :
  176.                   opbaum ( baum , wannklammern {                            } )
  177.               | mal  , durch :
  178.                   opbaum ( baum , wannklammern { plus , minus               } )
  179.               | hoch :
  180.                   opbaum ( baum , wannklammern { plus , minus , mal , durch } )
  181.               END (* CASE *)
  182.           | funktionsknoten :
  183.               IF ( max - i ) < fnamenlaenge THEN
  184.                 ok := FALSE
  185.               ELSE
  186.                 j := 1;
  187.                  REPEAT
  188.                    string [i] := fnamen [baum^.funktion , j];
  189.                    INC ( i );
  190.                    INC ( j )
  191.                  UNTIL fnamen [baum^.funktion , j] = blank;
  192.                  klammerbaum ( baum^.links )
  193.               END (* IF *)
  194.           | variablenknoten :
  195.               CASE baum^.variable OF
  196.                CHAR ( 255 ) :
  197.                 string [i] := 'Z';
  198.                 INC ( i );
  199.               |CHAR ( 254 ) :
  200.                 string [i] := 'Y';
  201.                 INC ( i );
  202.               |CHAR ( 253 ) :
  203.                 string [i] := 'X';
  204.                 INC ( i );
  205.               ELSE
  206.                 IF i > ( max - 4 ) THEN
  207.                   ok := FALSE
  208.                 ELSE
  209.                   ValToStr ( LONGINT ( baum^.variable ) , FALSE , feld , 10 ,
  210.                              3 , '0' , ok );
  211.                   ok := NOT ( ok );
  212.                   IF ok THEN
  213.                     string [i] := 'X';
  214.                     INC ( i );
  215.                     CopyPos ( string , feld , i );
  216.                     INC ( i , 3 );
  217.                   END (* IF *)
  218.                 END (* IF *)
  219.               END (* CASE *)
  220.           | reellzahlknoten :
  221.               RealToStr ( baum^.reellzahl , feld , -15 , 2 , FALSE , ok );
  222.               j          := 1;
  223.               ok         := TRUE;
  224.               negklammer := baum^.reellzahl < 0.;
  225.               IF negklammer THEN
  226.                 IF i < max THEN
  227.                   string [i] := '(';
  228.                   INC ( i )
  229.                 ELSE
  230.                   ok := FALSE
  231.                 END (* IF *)
  232.               END (* IF *);
  233.               WHILE ( i < max ) AND ( feld [j] # blank ) AND ( j <= 15 ) DO
  234.                 string [i] := feld [j];
  235.                 INC ( i );
  236.                 INC ( j )
  237.               END (* WHILE *);
  238.               IF ( i >= max ) OR ( feld [j] # blank ) THEN
  239.                 ok := FALSE
  240.               ELSE
  241.                 IF negklammer THEN
  242.                   string [i] := ')';
  243.                   INC ( i )
  244.                 END (* IF *)
  245.               END (* IF *)
  246.           | ganzzahlknoten :
  247.               ValToStr ( baum^.ganzzahl , TRUE , feld , 10 , -10 , ' ' , ok );
  248.               j          := 1;
  249.               ok         := TRUE;
  250.               negklammer := baum^.ganzzahl < 0;
  251.               IF negklammer THEN
  252.                 IF i < max THEN
  253.                   string [i] := '(';
  254.                   INC ( i )
  255.                 ELSE
  256.                   ok := FALSE
  257.                 END (* IF *)
  258.               END (* IF *);
  259.               WHILE ( i < max ) AND ( feld [j] # blank ) AND ( j <= 10 ) DO
  260.                 string [i] := feld [j];
  261.                 INC ( i );
  262.                 INC ( j )
  263.               END (* WHILE *);
  264.               IF i >= max THEN
  265.                 ok := FALSE
  266.               ELSE
  267.                 IF negklammer THEN
  268.                   string [i] := ')';
  269.                   INC ( i )
  270.                 END (* IF *)
  271.               END (* IF *)
  272.           END (* CASE *)
  273.         ELSE ok := FALSE
  274.         END (* IF *)
  275.       END (* IF *)
  276.     END infix2;
  277.  
  278.   BEGIN (* von infix *)
  279.     ok  := TRUE;
  280.     i   := 0;
  281.     max := HIGH ( string );
  282.     infix2      ( baum   );
  283.     IF ok THEN
  284.       string [i] := 0C
  285.     END (* IF *)
  286.   END infix;
  287.  
  288. PROCEDURE ableitung ( VAR f , fstrich : knotenzeiger ; variable : CHAR );
  289.  
  290.   PROCEDURE kopierebaum ( quelle : knotenzeiger ; VAR ziel : knotenzeiger );
  291.     BEGIN (* von kopierebaum *)
  292.       IF quelle # NIL THEN
  293.         ziel  := AllocMem ( SIZE ( knoten ) , MemReqSet {} );
  294.         ziel^ := quelle^;
  295.         kopierebaum ( quelle^.rechts , ziel^.rechts );
  296.         kopierebaum ( quelle^.links  , ziel^.links  )
  297.        ELSE ziel := NIL
  298.      END (* IF *)
  299.    END kopierebaum;
  300.  
  301.   PROCEDURE ableitung2 ( VAR baum : knotenzeiger );
  302.     VAR hilf , hilfl , hilfr : knotenzeiger;
  303.  
  304.     PROCEDURE negativ ( zeiger : knotenzeiger ) : knotenzeiger;
  305.       VAR hilf : knotenzeiger;
  306.       BEGIN
  307.         macheknoten ( hilf , operationsknoten      );
  308.         hilf^.operation       := mal;
  309.         hilf^.rechts          := zeiger;
  310.         macheknoten ( hilf^.links , ganzzahlknoten );
  311.         hilf^.links^.ganzzahl := -1;
  312.         RETURN      ( hilf                         )
  313.       END negativ;
  314.  
  315.     PROCEDURE wrzl ( zeiger : knotenzeiger ) : knotenzeiger;
  316.       VAR hilf : knotenzeiger;
  317.       BEGIN
  318.         macheknoten ( hilf , funktionsknoten       );
  319.         hilf^.funktion        := wurzel;
  320.         hilf^.links           := zeiger;
  321.         RETURN      ( hilf                         )
  322.       END wrzl;
  323.  
  324.     PROCEDURE reziprok ( zeiger : knotenzeiger ) : knotenzeiger;
  325.       VAR hilf : knotenzeiger;
  326.       BEGIN
  327.         macheknoten ( hilf , operationsknoten      );
  328.         hilf^.operation       := durch;
  329.         hilf^.rechts          := zeiger;
  330.         macheknoten ( hilf^.links , ganzzahlknoten );
  331.         hilf^.links^.ganzzahl := 1;
  332.         RETURN      ( hilf                         )
  333.       END reziprok;
  334.  
  335.     BEGIN (* von ableitung2 *)
  336.       IF baum # NIL THEN
  337.         CASE baum^.typ OF
  338.           operationsknoten:
  339.             CASE baum^.operation OF
  340.               plus , minus :
  341.                 ableitung2 ( baum^.links  );
  342.                 ableitung2 ( baum^.rechts )
  343.             | mal :
  344.                 kopierebaum      ( baum^.links  , hilfl     );
  345.                 kopierebaum      ( baum^.rechts , hilfr     );
  346.                 ableitung2       ( hilfl                    );
  347.                 ableitung2       ( hilfr                    );
  348.                 macheknoten      ( hilf  , operationsknoten );
  349.                 hilf^.operation  := mal;
  350.                 hilf^.links      := hilfl;
  351.                 hilf^.rechts     := baum^.rechts;
  352.                 baum^.rechts     := hilfr;
  353.                 macheknoten      ( hilfl , operationsknoten );
  354.                 hilfl^.operation := plus;
  355.                 hilfl^.links     := hilf;
  356.                 hilfl^.rechts    := baum;
  357.                 baum             := hilfl
  358.             | durch :
  359.                 kopierebaum     ( baum^.rechts , hilf     );
  360.                 baum^.operation := mal;
  361.                 ableitung2      ( baum                    );
  362.                 baum^.operation := minus;
  363.                 macheknoten     ( hilfl , funktionsknoten );
  364.                 hilfl^.funktion := quadrat;
  365.                 hilfl^.links    := hilf;
  366.                 macheknoten     ( hilf , operationsknoten );
  367.                 hilf^.operation := durch;
  368.                 hilf^.links     := baum;
  369.                 hilf^.rechts    := hilfl;
  370.                 baum            := hilf
  371.             | hoch :
  372.                 kopierebaum      ( baum , hilf              );
  373.                 baum^.operation  := mal;
  374.                 macheknoten      ( hilfl , funktionsknoten  );
  375.                 hilfl^.funktion  := lne;
  376.                 hilfl^.links     := baum^.links;
  377.                 baum^.links      := hilfl;
  378.                 ableitung2       ( baum                     );
  379.                 macheknoten      ( hilfl , operationsknoten );
  380.                 hilfl^.operation := mal;
  381.                 hilfl^.links     := hilf;
  382.                 hilfl^.rechts    := baum;
  383.                 baum             := hilfl
  384.             END (* CASE *)
  385.         | funktionsknoten :
  386.             kopierebaum ( baum^.links , hilf );
  387.             CASE baum^.funktion OF
  388.               sinush :
  389.                 baum^.funktion := cosinush
  390.             | cosinush :
  391.                 baum^.funktion := sinush
  392.             | tangensh :
  393.                 baum            := wrzl     ( baum );
  394.                 baum^.funktion  := quadrat;
  395.                 baum            := reziprok ( baum );
  396.                 baum^.operation := minus
  397.             | cotangensh :
  398.                 baum            := wrzl     ( baum );
  399.                 baum^.funktion  := quadrat;
  400.                 baum            := reziprok ( baum );
  401.                 baum^.operation := minus
  402.             | arsinush :
  403.                 baum^.funktion  := quadrat;
  404.                 baum            := reziprok ( baum );
  405.                 baum^.operation := plus;
  406.                 baum            := wrzl     ( baum );
  407.                 baum            := reziprok ( baum )
  408.             | arcosinush :
  409.                 baum^.funktion  := quadrat;
  410.                 baum            := negativ  ( baum );
  411.                 baum^.operation := plus;
  412.                 baum            := wrzl     ( baum );
  413.                 baum            := reziprok ( baum )
  414.             | artangensh :
  415.                 baum^.funktion  := quadrat;
  416.                 baum            := reziprok ( baum );
  417.                 baum^.operation := minus;
  418.                 baum            := reziprok ( baum )
  419.             | arcotangensh :
  420.                 baum^.funktion  := quadrat;
  421.                 baum            := reziprok ( baum );
  422.                 baum^.operation := minus;
  423.                 baum            := reziprok ( baum )
  424.             | sinus :
  425.                 baum^.funktion  := cosinus
  426.             | cosinus :
  427.                 baum^.funktion  := sinus;
  428.                 baum            := negativ  ( baum )
  429.             | tangens :
  430.                 baum            := wrzl     ( baum );
  431.                 baum^.funktion  := quadrat;
  432.                 baum            := reziprok ( baum );
  433.                 baum^.operation := plus
  434.             | cotangens :
  435.                 baum            := wrzl     ( baum );
  436.                 baum^.funktion  := quadrat;
  437.                 baum            := negativ  ( baum );
  438.                 baum^.operation := minus
  439.             | arcsinus :
  440.                 baum^.funktion  := quadrat;
  441.                 baum            := reziprok ( baum );
  442.                 baum^.operation := minus;
  443.                 baum            := wrzl     ( baum );
  444.                 baum            := reziprok ( baum )
  445.             | arccosinus :
  446.                 baum^.funktion  := quadrat;
  447.                 baum            := reziprok ( baum );
  448.                 baum^.operation := minus;
  449.                 baum            := wrzl     ( baum );
  450.                 baum            := reziprok ( baum );
  451.                 baum            := negativ  ( baum )
  452.             | arctangens :
  453.                 baum^.funktion  := quadrat;
  454.                 baum            := reziprok ( baum );
  455.                 baum^.operation := plus;
  456.                 baum            := reziprok ( baum )
  457.             | arccotangens :
  458.                 baum^.funktion  := quadrat;
  459.                 baum            := reziprok ( baum );
  460.                 baum^.operation := plus;
  461.                 baum            := reziprok ( baum );
  462.                 baum            := negativ  ( baum )
  463.             | ehoch :
  464.             | lne :
  465.                 hilfl := baum;
  466.                 baum  := baum^.links;
  467.                 FreeMem ( hilfl , SIZE ( knoten ) );
  468.                 baum  := reziprok ( baum )
  469.             | lg :
  470.                 hilfl            := baum;
  471.                 baum             := baum^.links;
  472.                 FreeMem                      ( hilfl , SIZE ( knoten ) );
  473.                 baum             := reziprok ( baum                    );
  474.                 baum             := reziprok ( baum                    );
  475.                 hilfl            := baum^.links;
  476.                 baum^.links      := baum^.rechts;
  477.                 baum^.rechts     := hilfl;
  478.                 hilfl^.typ       := reellzahlknoten;
  479.                 hilfl^.reellzahl := lnzehn
  480.             | pot10 :
  481.                 baum                   := negativ  ( baum );
  482.                 baum^.links^.typ       := reellzahlknoten;
  483.                 baum^.links^.reellzahl := lnzehn
  484.             | wurzel :
  485.                 baum                  := negativ  ( baum );
  486.                 baum^.links^.ganzzahl := 2;
  487.                 baum                  := reziprok ( baum )
  488.             | quadrat :
  489.                 baum^.typ              := operationsknoten;
  490.                 baum^.operation        := mal;
  491.                 macheknoten            ( baum^.rechts , ganzzahlknoten );
  492.                 baum^.rechts^.ganzzahl := 2
  493.             END (* CASE *);
  494.             ableitung2  ( hilf                     );
  495.             macheknoten ( hilfl , operationsknoten );
  496.             hilfl^.operation := mal;
  497.             hilfl^.links     := baum;
  498.             hilfl^.rechts    := hilf;
  499.             baum             := hilfl
  500.         | reellzahlknoten :
  501.             baum^.typ      := ganzzahlknoten;
  502.             baum^.ganzzahl := 0
  503.         | ganzzahlknoten :
  504.             baum^.ganzzahl := 0
  505.         | variablenknoten :
  506.             IF variable = baum^.variable THEN
  507.               baum^.typ      := ganzzahlknoten;
  508.               baum^.ganzzahl := 1
  509.             ELSE
  510.               baum^.typ      := ganzzahlknoten;
  511.               baum^.ganzzahl := 0
  512.            END (* IF *)
  513.         END (* CASE *)
  514.       END (* IF *)
  515.     END ableitung2;
  516.  
  517.   BEGIN (* von ableitung *)
  518.     ok := TRUE;
  519.     kopierebaum  ( f , fstrich );
  520.     ableitung2   ( fstrich     );
  521.     optimiere    ( fstrich     )
  522.   END ableitung;
  523.  
  524. PROCEDURE codeanf ( VAR operationen : ADDRESS );
  525.   BEGIN
  526.     kommandomsg.job := jobcodeanf;
  527.     PutMsg   ( kommandoport , ADR ( kommandomsg ) );
  528.     WaitPort ( replyportptr                       );
  529.     dummy           := GetMsg ( replyportptr      );
  530.     operationen     := kommandomsg.codeadr;
  531.     ok              := kommandomsg.fehlerflg = CHAR ( 0 )
  532.   END codeanf;
  533.  
  534. PROCEDURE codeloe ( VAR operationen  : ADDRESS );
  535.   BEGIN
  536.     kommandomsg.job     := jobcodeloe;
  537.     kommandomsg.codeadr := operationen;
  538.     PutMsg   ( kommandoport , ADR ( kommandomsg ) );
  539.     WaitPort ( replyportptr                       );
  540.     dummy               := GetMsg ( replyportptr  )
  541.   END codeloe;
  542.  
  543. PROCEDURE codegen ( operationen : ADDRESS ; VAR baum : knotenzeiger );
  544.   BEGIN (* von codegen *)
  545.     kommandomsg.job       := jobcodegen;
  546.     kommandomsg.codeadr   := operationen;
  547.     kommandomsg.knotenadr := baum;
  548.     PutMsg   ( kommandoport , ADR   ( kommandomsg ) );
  549.     WaitPort ( replyportptr                         );
  550.     dummy                 := GetMsg ( replyportptr  );
  551.     ok                    := kommandomsg.fehlerflg = CHAR ( 0 );
  552.     baum                  := kommandomsg.knotenadr
  553.   END codegen;
  554.  
  555. PROCEDURE funktion ( operationen : ADDRESS ) : FFP;
  556.   BEGIN
  557.     kommandomsg.job       := jobfunktion;
  558.     kommandomsg.codeadr   := operationen;
  559.     kommandomsg.xwert     := x;
  560.     kommandomsg.ywert     := y;
  561.     kommandomsg.zwert     := z;
  562.     PutMsg   ( kommandoport , ADR   ( kommandomsg )           );
  563.     WaitPort ( replyportptr                                   );
  564.     dummy                 := GetMsg ( replyportptr            );
  565.     ok                    := kommandomsg.fehlerflg = CHAR ( 0 );
  566.     RETURN   ( kommandomsg.ergebniss                          )
  567.   END funktion;
  568.  
  569. PROCEDURE parser ( VAR eingabe : ARRAY OF CHAR ; VAR baum : knotenzeiger );
  570.   VAR altpos : INTEGER;
  571.  
  572.   PROCEDURE azeichen () : CHAR;
  573.     BEGIN
  574.       RETURN ( eingabe [position] )
  575.     END azeichen;
  576.  
  577.   PROCEDURE nzeichen ();
  578.     BEGIN
  579.       altpos := position + 1;
  580.       REPEAT
  581.         INC ( position )
  582.       UNTIL eingabe [position] # blank
  583.     END nzeichen;
  584.  
  585.   PROCEDURE summand       ( VAR baum : knotenzeiger ); FORWARD;
  586.   PROCEDURE faktor        ( VAR baum : knotenzeiger ); FORWARD;
  587.   PROCEDURE basisexponent ( VAR baum : knotenzeiger ); FORWARD;
  588.   PROCEDURE funktion      ( VAR baum : knotenzeiger ); FORWARD;
  589.  
  590.   PROCEDURE holezahl ( VAR baum : knotenzeiger );
  591.     VAR vorkomma        : INTEGER;
  592.         wert , schieber : FFP;
  593.     BEGIN
  594.       macheknoten ( baum , ganzzahlknoten );
  595.       vorkomma := 0;
  596.       REPEAT
  597.         vorkomma := vorkomma * 10;
  598.         vorkomma := vorkomma + ORD ( azeichen () ) - ORD ( '0' );
  599.         nzeichen
  600.       UNTIL ( azeichen () < '0' ) OR ( azeichen () > '9' );
  601.       IF azeichen () <> '.' THEN
  602.         baum^.ganzzahl := vorkomma
  603.       ELSE
  604.         nzeichen;
  605.         baum^.typ := reellzahlknoten;
  606.         schieber  := 1.0;
  607.         wert      := 0.0;
  608.         WHILE ( azeichen () <= '9' ) AND ( azeichen () >= '0' ) DO
  609.           schieber := schieber / 10.;
  610.           wert     := wert + FFP ( ORD ( azeichen () ) - ORD ('0') ) *
  611.                              schieber;
  612.           nzeichen
  613.         END (* WHILE *);
  614.         baum^.reellzahl := FFP ( vorkomma ) + wert
  615.       END (* IF *)
  616.     END holezahl;
  617.  
  618.   PROCEDURE ausdruck ( VAR baum : knotenzeiger );
  619.     VAR hilf    : knotenzeiger;
  620.         zeichen : CHAR;
  621.         weiter  : BOOLEAN;
  622.     BEGIN
  623.       zeichen := azeichen ();
  624.       IF zeichen = '-' THEN
  625.         nzeichen;
  626.         macheknoten ( baum , operationsknoten      );
  627.         baum^.operation       := mal;
  628.         macheknoten ( baum^.links , ganzzahlknoten );
  629.         baum^.links^.ganzzahl := -1;
  630.         summand     ( baum^.rechts                 )
  631.       ELSE
  632.         IF zeichen = '+' THEN
  633.           nzeichen
  634.         END (* IF *);
  635.         summand ( baum )
  636.       END (* IF *);
  637.       weiter := TRUE;
  638.       WHILE ok AND weiter DO
  639.         zeichen := azeichen ();
  640.         IF ( zeichen = '+' ) OR ( zeichen = '-' ) THEN
  641.           nzeichen;
  642.           macheknoten ( hilf , operationsknoten );
  643.           IF zeichen = '+' THEN
  644.             hilf^.operation :=  plus
  645.           ELSE
  646.             hilf^.operation := minus
  647.           END (* IF *);
  648.           hilf^.links := baum;
  649.           baum        := hilf;
  650.           summand ( baum^.rechts );
  651.         ELSE
  652.           weiter := FALSE
  653.         END (* IF *)
  654.       END (* WHILE *)
  655.     END ausdruck;
  656.  
  657.   PROCEDURE summand ( VAR baum : knotenzeiger );
  658.     VAR hilf    : knotenzeiger;
  659.         weiter  : BOOLEAN;
  660.         zeichen : CHAR;
  661.     BEGIN
  662.       faktor ( baum );
  663.       weiter := TRUE;
  664.       WHILE ok AND weiter DO
  665.         zeichen := azeichen ();
  666.         IF ( zeichen = '*' ) OR ( zeichen = '/' ) THEN
  667.           nzeichen;
  668.           macheknoten ( hilf , operationsknoten );
  669.           IF zeichen = '*' THEN
  670.             hilf^.operation := mal
  671.           ELSE
  672.             hilf^.operation := durch
  673.           END (* IF *);
  674.           hilf^.links := baum;
  675.           baum        := hilf;
  676.           faktor ( baum^.rechts )
  677.         ELSE
  678.           weiter := FALSE
  679.         END (* IF *)
  680.       END (* WHILE *)
  681.     END summand;
  682.  
  683.   PROCEDURE faktor ( VAR baum : knotenzeiger );
  684.     VAR hilf : knotenzeiger;
  685.     BEGIN
  686.       basisexponent ( baum );
  687.       IF ok AND ( azeichen () = '^' ) THEN
  688.         nzeichen;
  689.         macheknoten   ( hilf , operationsknoten );
  690.         hilf^.operation := hoch;
  691.         hilf^.links     := baum;
  692.         baum            := hilf;
  693.         basisexponent ( baum^.rechts )
  694.       END (* IF *)
  695.     END faktor;
  696.  
  697.   PROCEDURE basisexponent ( VAR baum : knotenzeiger );
  698.     VAR zeichen : CHAR;
  699.         index   : INTEGER;
  700.     BEGIN
  701.       zeichen := azeichen ();
  702.       CASE zeichen OF
  703.         '0' , '1' , '2' , '3' , '4' , '5' , '6' , '7' , '8' , '9' :
  704.           holezahl ( baum  )
  705.       | 'P' :
  706.           IF eingabe [position + 1] = 'I' THEN
  707.             nzeichen;
  708.             nzeichen;
  709.             macheknoten ( baum , reellzahlknoten );
  710.             baum^.reellzahl := pizahl
  711.           ELSE
  712.             funktion ( baum )
  713.           END (* IF *)
  714.       | 'E' :
  715.           IF eingabe [position + 1] = 'U' THEN
  716.             nzeichen;
  717.             nzeichen;
  718.             macheknoten ( baum , reellzahlknoten );
  719.             baum^.reellzahl :=  ezahl
  720.           ELSE
  721.             funktion ( baum )
  722.           END (* IF *)
  723.       | 'X' , 'Y' , 'Z' :
  724.           nzeichen;
  725.           macheknoten ( baum , variablenknoten );
  726.           CASE zeichen OF
  727.             'X' :
  728.               zeichen := azeichen ();
  729.               IF ( zeichen >= '0' ) AND ( zeichen <= '9' ) THEN
  730.                 index := 0;
  731.                 REPEAT
  732.                   index := index * 10;
  733.                   index := index + ORD ( azeichen () ) - ORD ( '0' );
  734.                   nzeichen
  735.                 UNTIL ( azeichen () < '0' ) OR ( azeichen () > '9' );
  736.                 IF ( index > varanzahl ) THEN
  737.                   ok     := FALSE;
  738.                   fehler := falscherindex
  739.                 ELSE
  740.                   abhfeld [index] := TRUE;
  741.                   IF ( index > maxvar ) THEN
  742.                     maxvar := index
  743.                   END (* IF *);
  744.                   baum^.variable := CHAR ( index )
  745.                 END (* IF *)
  746.               ELSE
  747.                 xabh := TRUE;
  748.                 baum^.variable := CHAR ( 253 )
  749.               END (* IF *)
  750.           | 'Y' :
  751.               yabh := TRUE;
  752.               baum^.variable := CHAR ( 254 );
  753.           | 'Z' :
  754.               zabh := TRUE;
  755.               baum^.variable := CHAR ( 255 );
  756.           END (* CASE *);
  757.       | '(' :
  758.           nzeichen;
  759.           ausdruck ( baum );
  760.           IF ok THEN
  761.             IF azeichen () = ')' THEN
  762.               nzeichen
  763.             ELSE
  764.               ok     := FALSE;
  765.               fehler := klammerzuerwartet
  766.             END (* IF *)
  767.           END (* IF *)
  768.        ELSE (* OTHERWISE *)
  769.          funktion ( baum  )
  770.       END (* CASE *)
  771.     END basisexponent;
  772.  
  773.   PROCEDURE funktion ( VAR baum : knotenzeiger );
  774.     VAR fgefunden : BOOLEAN;
  775.         gleich    : BOOLEAN;
  776.         weiter    : BOOLEAN;
  777.         i         : funktionen;
  778.         j         : INTEGER;
  779.     BEGIN
  780.       fgefunden := FALSE;
  781.       i         := sinush;
  782.       REPEAT
  783.         j      := 0;
  784.         gleich := TRUE;
  785.         REPEAT
  786.           gleich := eingabe [position + j] = fnamen [i , j + 1];
  787.           INC ( j );
  788.         UNTIL NOT ( gleich ) OR ( fnamen [i , j + 1] = blank );
  789.         IF gleich THEN
  790.           fgefunden := TRUE;
  791.           position  := position + j
  792.         ELSE
  793.           INC ( i )
  794.         END (* IF *)
  795.       UNTIL fgefunden OR ( i = ende );
  796.       IF i = ende THEN
  797.         ok     := FALSE;
  798.         fehler := quatsch
  799.       ELSE
  800.         IF azeichen () = blank THEN
  801.           nzeichen
  802.         END (* IF *);
  803.         IF azeichen () = '(' THEN
  804.           nzeichen;
  805.           macheknoten ( baum , funktionsknoten );
  806.           baum^.funktion := i;
  807.           ausdruck    ( baum^.links            );
  808.           IF ok THEN
  809.             IF azeichen () = ')' THEN
  810.               nzeichen;
  811.             ELSE
  812.               ok     := FALSE;
  813.               fehler := klammerzuerwartet
  814.             END (* IF *)
  815.           END (* IF *)
  816.         ELSE
  817.           ok     := FALSE;
  818.           fehler := klammerauferwartet
  819.         END (* IF *)
  820.       END (* IF *)
  821.     END funktion;
  822.  
  823.   BEGIN (* von parser *)
  824.     FOR position := 1 TO varanzahl DO
  825.       abhfeld [position] := FALSE
  826.     END (* FOR *);
  827.     FOR position := 0 TO HIGH ( eingabe ) DO
  828.       eingabe [position] := CAP ( eingabe [position] )
  829.     END (* FOR *);
  830.     maxvar   := -1;
  831.     position := -1;
  832.     altpos   := -1;
  833.     baum     := NIL;
  834.     xabh     := FALSE;
  835.     yabh     := FALSE;
  836.     zabh     := FALSE;
  837.     ok       := TRUE;
  838.     nzeichen (      );
  839.     ausdruck ( baum );
  840.     IF ok AND NOT ( eingabe [position] = endezeichen ) THEN
  841.       ok     := FALSE;
  842.       fehler := woistdastermende
  843.     END (* IF *);
  844.     IF ok THEN
  845.       optimiere    ( baum );
  846.     END (* IF *);
  847.     position := altpos
  848.   END parser;
  849.  
  850. PROCEDURE loesche ( VAR baum : knotenzeiger );
  851.   BEGIN
  852.     IF baum # NIL THEN
  853.       loesche ( baum^.links            );
  854.       loesche ( baum^.rechts           );
  855.       FreeMem ( baum , SIZE ( knoten ) );
  856.       baum := NIL
  857.     END (* IF *)
  858.   END loesche;
  859.  
  860. PROCEDURE optimiere ( VAR baum : knotenzeiger );
  861.  VAR optcode : ADDRESS;
  862.  
  863.   PROCEDURE loeschelinks ( baum : knotenzeiger ) : knotenzeiger;
  864.     VAR helfer : knotenzeiger;
  865.     BEGIN (* von loeschelinks  *)
  866.       helfer := baum^.rechts;
  867.       loesche    ( baum^.links            );
  868.       FreeMem    ( baum , SIZE ( knoten ) );
  869.       RETURN     ( helfer                 )
  870.     END loeschelinks;
  871.  
  872.   PROCEDURE loescherechts ( baum : knotenzeiger ) : knotenzeiger;
  873.     VAR helfer : knotenzeiger;
  874.     BEGIN (* von loescherechts *)
  875.       helfer := baum^.links;
  876.       loesche    ( baum^.rechts           );
  877.       FreeMem    ( baum , SIZE ( knoten ) );
  878.       RETURN     ( helfer                 )
  879.     END loescherechts;
  880.  
  881.   PROCEDURE optimiere2 ( VAR baum : knotenzeiger );
  882.     VAR lizgr , rezgr : knotenzeiger;
  883.  
  884.     PROCEDURE konstausdruck ( VAR baum : knotenzeiger );
  885.       VAR lizgr , rezgr : knotenzeiger;
  886.           wert          : FFP;
  887.           ganzzahlig    : BOOLEAN;
  888.       BEGIN
  889.         lizgr := baum^.links;
  890.         rezgr := baum^.rechts;
  891.         IF baum^.typ = operationsknoten THEN
  892.           IF ( lizgr^.typ = ganzzahlknoten  ) OR
  893.              ( lizgr^.typ = reellzahlknoten ) THEN
  894.             IF ( rezgr^.typ = ganzzahlknoten  ) OR
  895.                ( rezgr^.typ = reellzahlknoten ) THEN
  896.               ganzzahlig := ( rezgr^.typ = ganzzahlknoten );
  897.               IF ( baum^.operation = durch           ) OR
  898.                  ( lizgr^.typ      = reellzahlknoten ) THEN
  899.                 ganzzahlig := FALSE
  900.               END;
  901.               codegen          ( optcode , baum );
  902.               wert := funktion ( optcode        );
  903.               IF ok THEN
  904.                 baum := loescherechts ( baum );
  905.                 IF ganzzahlig AND ( ABS ( wert ) < 32000. ) THEN
  906.                   baum^.typ := ganzzahlknoten;
  907.                   IF wert > 0. THEN
  908.                     baum^.ganzzahl := TRUNC ( wert + 0.5 )
  909.                   ELSE
  910.                     baum^.ganzzahl := TRUNC ( wert - 0.5 )
  911.                   END (* IF *)
  912.                 ELSE
  913.                   baum^.typ       := reellzahlknoten;
  914.                   baum^.reellzahl := wert
  915.                 END (* IF *)
  916.               END (* IF *)
  917.             END (* IF *)
  918.           END (* IF *)
  919.         ELSIF baum^.typ = funktionsknoten THEN
  920.           IF ( lizgr^.typ = ganzzahlknoten  ) OR
  921.              ( lizgr^.typ = reellzahlknoten ) THEN
  922.             ganzzahlig := lizgr^.typ = ganzzahlknoten;
  923.             IF baum^.funktion # quadrat THEN
  924.               ganzzahlig := FALSE
  925.             END (* IF *);
  926.             codegen          ( optcode , baum );
  927.             wert := funktion ( optcode        );
  928.             IF ok THEN
  929.               baum := loescherechts ( baum );
  930.               IF ganzzahlig AND ( ABS ( wert ) < 32000. ) THEN
  931.                 baum^.typ := ganzzahlknoten;
  932.                 IF wert > 0. THEN
  933.                   baum^.ganzzahl := TRUNC ( wert + 0.5 )
  934.                 ELSE
  935.                   baum^.ganzzahl := TRUNC ( wert - 0.5 )
  936.                 END (* IF *)
  937.               ELSE
  938.                 baum^.typ       := reellzahlknoten;
  939.                 baum^.reellzahl := wert
  940.               END (* IF *)
  941.             END (* IF *)
  942.           END (* IF *)
  943.         END (* IF *)
  944.       END konstausdruck;
  945.  
  946.     BEGIN (* von optimiere2 *)
  947.       IF baum # NIL THEN
  948.         optimiere2    ( baum^.links  );
  949.         optimiere2    ( baum^.rechts );
  950.         konstausdruck ( baum         );
  951.         IF ok AND ( baum^.typ = operationsknoten ) THEN
  952.           lizgr := baum^.links;
  953.           rezgr := baum^.rechts;
  954.           IF lizgr^.typ = ganzzahlknoten THEN
  955.             CASE baum^.operation OF
  956.               plus  : IF lizgr^.ganzzahl = 0 THEN
  957.                         baum := loeschelinks ( baum )
  958.                       END (* IF *)
  959.             | mal   : CASE lizgr^.ganzzahl OF
  960.                         -1 : lizgr^.ganzzahl := 0;
  961.                              baum^.operation := minus;
  962.                       |  0 : baum            := loescherechts ( baum )
  963.                       |  1 : baum            := loeschelinks  ( baum )
  964.                       ELSE
  965.                       END (* CASE *)
  966.             | durch : IF lizgr^.ganzzahl = 0 THEN
  967.                         baum := loescherechts ( baum )
  968.                       END (* IF *)
  969.             | hoch  : IF ( lizgr^.ganzzahl = 0 ) OR
  970.                          ( lizgr^.ganzzahl = 1 ) THEN
  971.                         baum := loescherechts ( baum )
  972.                       END (* IF *)
  973.               ELSE
  974.             END (* CASE *)
  975.           ELSIF rezgr^.typ = ganzzahlknoten THEN
  976.             CASE baum^.operation OF
  977.               plus , minus :
  978.                IF rezgr^.ganzzahl = 0 THEN
  979.                  baum := loescherechts ( baum )
  980.                END (* IF *)
  981.             | mal :
  982.                CASE rezgr^.ganzzahl OF
  983.                  -1 : rezgr^.ganzzahl := 0;
  984.                       baum^.operation := minus;
  985.                       baum^.links     := rezgr;
  986.                       baum^.rechts    := lizgr
  987.                |  0 : baum            := loeschelinks  ( baum )
  988.                |  1 : baum            := loescherechts ( baum )
  989.                  ELSE
  990.                END (* CASE *)
  991.             | durch :
  992.                IF rezgr^.ganzzahl = 1 THEN
  993.                  baum := loescherechts ( baum );
  994.                ELSIF rezgr^.ganzzahl = -1 THEN
  995.                  rezgr^.ganzzahl := 0;
  996.                  baum^.operation := minus;
  997.                  baum^.links     := rezgr;
  998.                  baum^.rechts    := lizgr
  999.                END (* IF *)
  1000.             | hoch :
  1001.                CASE rezgr^.ganzzahl OF
  1002.                  -1 : rezgr^.ganzzahl := 1;
  1003.                       baum^.operation := durch;
  1004.                       baum^.links     := rezgr;
  1005.                       baum^.rechts    := lizgr
  1006.                |  0 : baum            := loeschelinks  ( baum );
  1007.                       baum^.ganzzahl  := 1
  1008.                |  1 : baum            := loescherechts ( baum )
  1009.                 ELSE
  1010.               END (* CASE *)
  1011.             END (* CASE *)
  1012.           END (* IF *)
  1013.         ELSE
  1014.           ok := TRUE
  1015.         END (* IF *)
  1016.       END (* IF *)
  1017.     END optimiere2;
  1018.  
  1019.   BEGIN (* von optimiere *)
  1020.     codeanf    ( optcode );
  1021.     ok := TRUE;
  1022.     optimiere2 ( baum    );
  1023.     codeloe    ( optcode )
  1024.   END optimiere;
  1025.  
  1026. BEGIN (* von analyse *)
  1027.   fnamen [sinush      ] := 'SINH   ';
  1028.   fnamen [cosinush    ] := 'COSH   ';
  1029.   fnamen [tangensh    ] := 'TANH   ';
  1030.   fnamen [cotangensh  ] := 'COTH   ';
  1031.   fnamen [arsinush    ] := 'ARSINH ';
  1032.   fnamen [arcosinush  ] := 'ARCOSH ';
  1033.   fnamen [artangensh  ] := 'ARTANH ';
  1034.   fnamen [arcotangensh] := 'ARCOTH ';
  1035.   fnamen [sinus       ] := 'SIN    ';
  1036.   fnamen [cosinus     ] := 'COS    ';
  1037.   fnamen [tangens     ] := 'TAN    ';
  1038.   fnamen [cotangens   ] := 'COT    ';
  1039.   fnamen [arcsinus    ] := 'ARCSIN ';
  1040.   fnamen [arccosinus  ] := 'ARCCOS ';
  1041.   fnamen [arctangens  ] := 'ARCTAN ';
  1042.   fnamen [arccotangens] := 'ARCCOT ';
  1043.   fnamen [ehoch       ] := 'EXP    ';
  1044.   fnamen [lne         ] := 'LN     ';
  1045.   fnamen [lg          ] := 'LOG    ';
  1046.   fnamen [pot10       ] := 'POT10  ';
  1047.   fnamen [wurzel      ] := 'WRZL   ';
  1048.   fnamen [quadrat     ] := 'QUAD   ';
  1049.   serverseg    := LoadSeg ( ADR ( "devs:server" ) );
  1050.   Assert ( serverseg  # NIL , ADR ( "Server läßt sich nicht laden"  ) );
  1051.   serverproc   :=  CreateProc ( ADR ( "server" ) , 0 , serverseg , 1024 );
  1052.   Assert ( serverproc # NIL , ADR ( "serverproc nicht startbar."    ) );
  1053.   replyportptr := CreatePort ( NIL , 0 );
  1054.   startupmsg.startupkopf.replyPort   := replyportptr;
  1055.   startupmsg.startupkopf.length      := 1;
  1056.   startupmsg.errorflg                := CHAR ( 0 );
  1057.   kommandomsg.kommandokopf.replyPort := replyportptr;
  1058.   kommandomsg.kommandokopf.length    := 26;
  1059.   startupmsg.kportadr                := ADR ( varfeld );
  1060.   PutMsg   ( serverproc , ADR ( startupmsg ) );
  1061.   WaitPort ( replyportptr                    );
  1062.   dummy        := GetMsg ( replyportptr             );
  1063.   Assert ( startupmsg.errorflg = CHAR ( 0 ) , ADR ( "Lib. geht nicht auf." ) );
  1064.   kommandoport := startupmsg.kportadr;
  1065.   TermProcedure ( shootdownserver )
  1066. END analyse.
  1067.